GFIndexCol (to be deleted)/GFIndexCol.cls
VERSION 1.0 CLASS
BEGIN
MultiUse = ‑1 'True
Persistable = 0 'NotPersistable
DataBindingBehavior = 0 'vbNone
DataSourceBehavior = 0 'vbNone
MTSTransactionMode = 0 'NotAnMTSObject
END
Attribute VB_Name = "GFIndexCol"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'(c)2003 by Louis. Class that serves as an index collection.
'TagArray
#Const TagArraySupportEnabledFlag = True 'importing when reading/writing INDEXCOL file
'File operations
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
'IndexArray
Dim IndexNumberGlobal As Long
Dim IndexArrayGlobal() As Long
'
'NOTE: the TagArray's size and content is manipulated together with IndexArrayGlobal().
'Note that there's NO Receive(), InCol(), etc. support (but there IS WriteToFile()/ReadFromFile() support).
'WARNING: the TagArray code may be buggy!
'
#If TagArraySupportEnabledFlag = True Then
Dim TagArrayGlobal() As New GFIndexColLight 'don't use normal collection to save memory
#End If
'***INDEX ADDING/REMOVING***
Public Sub Index_Add(ByVal Index As Long)
'on error resume next
IndexNumberGlobal = IndexNumberGlobal + 1&
If ((IndexNumberGlobal ‑ 1&) Mod 4096&) = 0& Then 'don't allocate too much or we'll become slow when creating many class instances
ReDim Preserve IndexArrayGlobal(1 To (IndexNumberGlobal + 4095&)) As Long
ReDim Preserve TagArrayGlobal(1 To (IndexNumberGlobal + 4095&)) As New GFIndexColLight
End If
IndexArrayGlobal(IndexNumberGlobal) = Index
End Sub
Public Function Index_AddIfNotExisting(ByVal Index As Long) As Boolean
'on error resume next 'returns True if index has been added, False if not
Dim IndexFor As Long
'begin
For IndexFor = 1& To IndexNumberGlobal
If IndexArrayGlobal(IndexFor) = Index Then
Index_AddIfNotExisting = False
Exit Function
End If
Next IndexFor
Call Index_Add(Index) 'add the index
Index_AddIfNotExisting = True
Exit Function
End Function
Public Function Index_Push(ByVal Index As Long, ByVal IndexNumberMax As Long)
'on error resume next 'abcde+f‑>bcdef (IndexNumberMax=5)
If IndexNumberGlobal >= IndexNumberMax Then
Call Me.MoveBlock(‑1&, ‑1&, ‑1&, ‑1&)
Call Me.Left(IndexNumberMax ‑ 1&)
End If
Call Me.Index_Add(Index)
End Function
Public Function Index_Remove(ByVal Index As Long, Optional ByVal IndexColIndex As Long = 0&) As Boolean
'On Error Resume Next 'removes index from collection (pass the value you passed to Index_Add(), or the array index); returns True if successfull, False if not
Dim IndexFor As Long
'begin
If (IndexColIndex = 0&) Then IndexColIndex = Me.GetIndexArrayIndex(Index, 1&)
If (IndexColIndex) Then
For IndexFor = IndexColIndex To (IndexNumberGlobal ‑ 1&)
IndexArrayGlobal(IndexFor) = IndexArrayGlobal(IndexFor + 1&)
TagArrayGlobal(IndexFor) = TagArrayGlobal(IndexFor + 1&)
Next IndexFor
IndexNumberGlobal = IndexNumberGlobal ‑ 1&
'don't resize, too much work ;‑P (resizing in steps)
Index_Remove = True
Exit Function
Else
Index_Remove = False
Exit Function
End If
End Function
Public Sub Clear()
'on error resume next
IndexNumberGlobal = 0 'reset
ReDim IndexArrayGlobal(1 To 1) As Long
ReDim TagArrayGlobal(1 To 1) As New GFIndexColLight
End Sub
Public Function Copy(ByRef OtherIndexCol As GFIndexCol, Optional ByVal FirstXIndicesOnly As Long = ‑1&, Optional ByVal LastXIndicesOnly As Long = ‑1&) As Long
'on error resume next 'copies and returns number of indices copied
Call Me.Clear
Copy = Me.Receive(OtherIndexCol, FirstXIndicesOnly, LastXIndicesOnly)
End Function
Public Function Receive(ByRef OtherIndexCol As GFIndexCol, Optional ByVal FirstXIndicesOnly As Long = ‑1&, Optional ByVal LastXIndicesOnly As Long = ‑1&) As Long
'on error resume next 'use to copy one GFIndexCol into an other one; return number of indices copied
Dim ForMin As Long
Dim ForMax As Long
Dim IndexFor As Long
'preset
ForMin = 1&
ForMax = OtherIndexCol.IndexNumber
If Not (FirstXIndicesOnly = ‑1&) Then
ForMin = 1&
ForMax = FirstXIndicesOnly
If ForMax > OtherIndexCol.IndexNumber Then ForMax = OtherIndexCol.IndexNumber
End If
If Not (LastXIndicesOnly = ‑1&) Then
ForMin = OtherIndexCol.IndexNumber ‑ LastXIndicesOnly + 1&
If ForMin < 1& Then ForMin = 1&
ForMax = OtherIndexCol.IndexNumber
End If
'begin
For IndexFor = ForMin To ForMax
Call Me.Index_Add(OtherIndexCol.IndexArray(IndexFor))
Next IndexFor
Receive = OtherIndexCol.IndexNumber
End Function
'***END OF INDEX ADDING/REMOVING***
'***SEARCH FUNCTIONS***
Public Function GetIndexArrayIndex(ByVal Index As Long, Optional ByVal SearchStartPos As Long = 1&) As Long
'on error resume next 'returns index of array element that is equal to the passed index (or 0 if index not found)
Dim IndexFor As Long
'
'NOTE: if this function returns 0 then the passed index has not been added yet,
'if the function returns a non‑zero (greater 0) index then the passed index was added.
'
'verify
If (SearchStartPos < 1) Or (SearchStartPos > IndexNumberGlobal) Then
GetIndexArrayIndex = 0&
Exit Function
End If
'begin
For IndexFor = SearchStartPos To IndexNumberGlobal
If IndexArrayGlobal(IndexFor) = Index Then
GetIndexArrayIndex = IndexFor
Exit Function
End If
Next IndexFor
GetIndexArrayIndex = 0&
Exit Function
End Function
Public Function GetIndexArrayIndexRev(ByVal Index As Long, Optional ByVal SearchStartPos As Long = ‑1&) As Long
'on error resume next 'returns index of array element that is equal to the passed index (or 0 if index not found)
Dim IndexFor As Long
'
'NOTE: if this function returns 0 then the passed index has not been added yet,
'if the function returns a non‑zero (greater 0) index then the passed index was added.
'
'verify
If SearchStartPos = ‑1& Then SearchStartPos = IndexNumberGlobal
If (SearchStartPos < 1) Or (SearchStartPos > IndexNumberGlobal) Then
GetIndexArrayIndexRev = 0&
Exit Function
End If
'begin
For IndexFor = SearchStartPos To 1& Step (‑1&)
If IndexArrayGlobal(IndexFor) = Index Then
GetIndexArrayIndexRev = IndexFor
Exit Function
End If
Next IndexFor
GetIndexArrayIndexRev = 0&
Exit Function
End Function
Public Function GetSmallestIndexArrayIndexGreaterThan(ByVal Index As Long, Optional ByVal SearchStartPos As Long = 1&, Optional ByVal EqualAllowedFlag As Boolean = False) As Long
'on error resume next 'returns index of array element that is greater than or equal to the passed index (or 0 if index not found)
Dim IndexMin As Long
Dim IndexMinIndex As Long
Dim IndexFor As Long
'verify
If (SearchStartPos < 1) Or (SearchStartPos > IndexNumberGlobal) Then
GetSmallestIndexArrayIndexGreaterThan = 0&
Exit Function
End If
'begin
If (EqualAllowedFlag) Then
IndexMin = 256& ^ 3& 'preset
For IndexFor = SearchStartPos To IndexNumberGlobal
If IndexArrayGlobal(IndexFor) >= Index Then
If IndexArrayGlobal(IndexFor) < IndexMin Then
IndexMin = IndexArrayGlobal(IndexFor)
IndexMinIndex = IndexFor
End If
End If
Next IndexFor
If IndexMinIndex = 0& Then IndexMin = 0& 'return 0 if no index found
GetSmallestIndexArrayIndexGreaterThan = IndexMin
Exit Function
Else
IndexMin = 256& ^ 3& 'preset
For IndexFor = SearchStartPos To IndexNumberGlobal
If IndexArrayGlobal(IndexFor) > Index Then
If IndexArrayGlobal(IndexFor) < IndexMin Then
IndexMin = IndexArrayGlobal(IndexFor)
IndexMinIndex = IndexFor
End If
End If
Next IndexFor
If IndexMinIndex = 0& Then IndexMin = 0& 'return 0 if no index found
GetSmallestIndexArrayIndexGreaterThan = IndexMin
Exit Function
End If
'GetSmallestIndexArrayIndexGreaterThan = 0&
'Exit Function
End Function
Public Function InCol(ByVal SearchStartPos As Long, ByRef SearchGFIndexCol As GFIndexCol) As Long
'on error resume next 'returns match start pos or 0 for not found
Dim IndexFor1 As Long
Dim IndexFor2 As Long
'verify
Select Case SearchGFIndexCol.IndexNumber
Case Is < 1&, Is > IndexNumberGlobal
InCol = 0&
Exit Function
End Select
'begin
IndexFor2 = 1& 'preset
For IndexFor1 = 1& To (IndexNumberGlobal ‑ SearchGFIndexCol.IndexNumber + 1&)
If IndexArrayGlobal(IndexFor1) = SearchGFIndexCol.IndexArray(1) Then
For IndexFor2 = 2& To SearchGFIndexCol.IndexNumber
If Not (IndexArrayGlobal(IndexFor1 + IndexFor2 ‑ 1&) = SearchGFIndexCol.IndexArray(IndexFor2)) Then
GoTo Jump: '*VIVA* GoTo!!!
End If
Next IndexFor2
InCol = IndexFor1
Exit Function
End If
Jump:
Next IndexFor1
InCol = 0&
Exit Function
End Function
Public Function IsEqual(ByRef OtherIndexCol As GFIndexCol) As Boolean
'on error resume next 'returns True if exactly equal, False if not
Dim IndexFor As Long
'verify
If Not (OtherIndexCol.IndexNumber = Me.IndexNumber) Then
IsEqual = False
Exit Function
End If
'begin
For IndexFor = 1& To IndexNumberGlobal
If Not (IndexArrayGlobal(IndexFor) = OtherIndexCol.IndexArray(IndexFor)) Then
IsEqual = False
Exit Function
End If
Next IndexFor
IsEqual = True
Exit Function
End Function
'***END OF SEARCH FUNCTIONS***
'***MANIPULATION FUNCTIONS***
Public Function Left(ByVal RetainIndexNumber As Long) As Long
'on error resume next 'returns new number of elements in collection
If RetainIndexNumber < 0& Then RetainIndexNumber = 0& 'verify
If RetainIndexNumber > IndexNumberGlobal Then RetainIndexNumber = IndexNumberGlobal 'verify
IndexNumberGlobal = RetainIndexNumber 'easy and it works!
Left = IndexNumberGlobal
End Function
Public Function Right(ByVal RetainIndexNumber As Long) As Long
'on error resume next 'returns new number of elements in collection
If RetainIndexNumber < 0& Then RetainIndexNumber = 0& 'verify
If RetainIndexNumber > IndexNumberGlobal Then RetainIndexNumber = IndexNumberGlobal 'verify
If (RetainIndexNumber) Then 'don't move if retain number 0
Call Me.MoveBlock(IndexNumberGlobal ‑ RetainIndexNumber + 1&, ‑1&, ‑(IndexNumberGlobal ‑ RetainIndexNumber), ‑1&) 'slow, but easy to program
End If
IndexNumberGlobal = RetainIndexNumber
Right = IndexNumberGlobal
End Function
Public Function CutOut(ByVal CutStartIndex As Long, ByVal CutEndIndex As Long) As Long
'on error resume next 'removes block (including borders) from collection; returns number of retained indices
Dim TempGFIndexCol As New GFIndexCol
Dim Temp As Long
'begin
For Temp = 1 To IndexNumberGlobal
If (Temp < CutStartIndex) Or (Temp > CutEndIndex) Then 'if start pos > end pos then nothing's cut (like in a For loop)
Call TempGFIndexCol.Index_Add(IndexArrayGlobal(Temp))
End If
Next Temp
Call Me.Clear
Call Me.Receive(TempGFIndexCol)
CutOut = TempGFIndexCol.IndexNumber
End Function
Public Function Retain(ByVal RetainStartIndex As Long, ByVal RetainEndIndex As Long) As Long
'on error resume next 'retains block (including borders) of collection (inverse of CutOut); returns number of retained indices
Dim TempGFIndexCol As New GFIndexCol
Dim Temp As Long
'begin
For Temp = 1& To IndexNumberGlobal
If (Temp >= RetainStartIndex) And (Temp <= RetainEndIndex) Then
TempGFIndexCol.Index_Add (IndexArrayGlobal(Temp))
End If
Next Temp
Call Me.Clear
Call Me.Receive(TempGFIndexCol)
Retain = TempGFIndexCol.IndexNumber
End Function
Public Sub Fill(ByVal FillStartIndex As Long, ByVal FillEndIndex As Long, ByVal FillIndex As Long)
'on error resume next 'Fills block (including borders) of collection (inverse of CutOut)
Dim Temp As Long
'verify
If FillStartIndex = ‑1& Then FillStartIndex = 1&
If FillEndIndex = ‑1& Then FillEndIndex = IndexNumberGlobal
'begin
For Temp = 1& To IndexNumberGlobal
If (Temp >= FillStartIndex) And (Temp <= FillEndIndex) Then
IndexArrayGlobal(Temp) = FillIndex
End If
Next Temp
End Sub
Public Function MoveBlock(ByVal BlockStartPos As Long, ByVal BlockEndPos As Long, ByVal BlockMoveValue As Long, ByVal FillIndex As Long) As Boolean
'on error resume next 'better way to cut out indices; Example: to cut 'vb' from 'hello vb world' call MoveBlock(10, ‑1, ‑3, 32) (indices := ascii‑codes)
Dim FillFor As Long
Dim Temp As Long
'verify
If BlockMoveValue = 0& Then
MoveBlock = True 'no error
Exit Function
End If
If BlockMoveValue > 0& Then
If BlockStartPos = ‑1& Then BlockStartPos = 1& 'use ‑1 for 'whole block'
If BlockEndPos = ‑1& Then BlockEndPos = IndexNumberGlobal ‑ BlockMoveValue 'use ‑1 for 'whole block'
Else
If BlockStartPos = ‑1& Then BlockStartPos = 1& ‑ BlockMoveValue 'use ‑1 for 'whole block'
If BlockEndPos = ‑1& Then BlockEndPos = IndexNumberGlobal 'use ‑1 for 'whole block'
End If
If (BlockStartPos < 1&) Or (BlockStartPos > IndexNumberGlobal) Then
MoveBlock = False
Exit Function
End If
If (BlockEndPos < 1&) Or (BlockEndPos > IndexNumberGlobal) Then
MoveBlock = False
Exit Function
End If
If ((BlockStartPos + BlockMoveValue) < 1&) Or ((BlockStartPos + BlockMoveValue) > IndexNumberGlobal) Then
MoveBlock = False
Exit Function
End If
If ((BlockEndPos + BlockMoveValue) < 1&) Or ((BlockEndPos + BlockMoveValue) > IndexNumberGlobal) Then
MoveBlock = False
Exit Function
End If
'begin
Call CopyMemory(IndexArrayGlobal(BlockStartPos + BlockMoveValue), IndexArrayGlobal(BlockStartPos), (BlockEndPos ‑ BlockStartPos + 1&) * 4&)
If BlockMoveValue > 0& Then 'move to right
For Temp = ((BlockEndPos ‑ BlockStartPos + 1&) ‑ 1&) To 0& Step (‑1&)
Set TagArrayGlobal(BlockStartPos + BlockMoveValue + Temp) = TagArrayGlobal(BlockStartPos + Temp)
Next Temp
Else 'move to left
For Temp = 0& To ((BlockEndPos ‑ BlockStartPos + 1&) ‑ 1&)
Set TagArrayGlobal(BlockStartPos + BlockMoveValue + Temp) = TagArrayGlobal(BlockStartPos + Temp)
Next Temp
End If
If FillIndex > 0& Then 'pass ‑1& to disable filling (faster)
If BlockMoveValue > 0& Then
For FillFor = BlockStartPos To (BlockStartPos + BlockMoveValue ‑ 1&)
IndexArrayGlobal(FillFor) = FillIndex
Next FillFor
Else
For FillFor = (BlockEndPos + BlockMoveValue + 1&) To BlockEndPos
IndexArrayGlobal(FillFor) = FillIndex
Next FillFor
End If
End If
MoveBlock = True
Exit Function
End Function
'***END OF MANIPULATION FUNCTIONS***
'***FILE FUNCTIONS***
Public Function WriteToFile(ByVal FileDescriptor As Integer) As Long
'on error resume next 'returns number of array indices written (no error checking, 0 needn't to mean error)
Dim IndexString As String * 4
Dim IndexFor As Long
'preset
Print #FileDescriptor, "INDEXCOL";
Call CopyMemory(ByVal IndexString, IndexNumberGlobal, 4&)
Print #FileDescriptor, IndexString;
'begin
For IndexFor = 1& To IndexNumberGlobal
Call CopyMemory(ByVal IndexString, IndexArrayGlobal(IndexFor), 4&)
Print #FileDescriptor, IndexString;
#If TagArraySupportEnabledFlag = True Then
Call TagArrayGlobal(IndexFor).WriteToFile(FileDescriptor)
#End If
Next IndexFor
WriteToFile = IndexNumberGlobal
End Function
Public Function ReadFromFile(ByVal FileDescriptor As Integer) As Long
'on error resume next 'returns number of indices read (‑1 for error), jumps back to original file position if no index col header existing
Dim Index As Long
Dim IndexNumberLocal As Long
Dim IndexString As String * 4
Dim IndexFor As Long
'verify
Get #FileDescriptor, , IndexString
If Not (IndexString = "INDE") Then
Seek #FileDescriptor, Seek(FileDescriptor) ‑ 4&
ReadFromFile = ‑1&
Exit Function
End If
Get #FileDescriptor, , IndexString
If Not (IndexString = "XCOL") Then
Seek #FileDescriptor, Seek(FileDescriptor) ‑ 8&
ReadFromFile = ‑1&
Exit Function
End If
'reset
Call Me.Clear
'begin
Get #FileDescriptor, , IndexString
Call CopyMemory(IndexNumberLocal, ByVal IndexString, 4&)
For IndexFor = 1& To IndexNumberLocal
Get #FileDescriptor, , IndexString
Call CopyMemory(Index, ByVal IndexString, 4&)
Call Me.Index_Add(Index)
#If TagArraySupportEnabledFlag = True Then
Call TagArrayGlobal(IndexNumberGlobal).ReadFromFile(FileDescriptor)
#End If
Next IndexFor
ReadFromFile = IndexNumberLocal
End Function
'***END OF FILE FUNCTIONS***
'***PROPERTIES***
Public Property Set IndexNumber() As Long
'on error resume next
IndexNumber = IndexNumberGlobal
End Property
Public Property Set IndexArray(ByVal IndexArrayIndex As Long) As Long
'on error resume next 'calling procedure must verify passed index is valid
If IndexArrayIndex = ‑1& Then
IndexArrayIndex = IndexNumberGlobal
If IndexArrayIndex = 0& Then
IndexArray = 0& '0 for empty
Exit Property
End If
End If
IndexArray = IndexArrayGlobal(IndexArrayIndex)
Exit Property
End Property
Public Property Let IndexArray(ByVal IndexArrayIndex As Long, ByVal Index As Long)
'on error resume next 'calling procedure must verify passed (IndexArray‑) index is valid
IndexArrayGlobal(IndexArrayIndex) = Index
End Property
Public Property Set TagArray(ByVal TagArrayIndex As Long) As GFIndexColLight
'on error resume next
If TagArrayIndex = ‑1& Then
TagArrayIndex = IndexNumberGlobal
If TagArrayIndex = 0& Then
Set TagArray = Nothing 'Nothing for empty
Exit Property
End If
End If
Set TagArray = TagArrayGlobal(TagArrayIndex)
Exit Property
End Property
'***END OF PROPERTIES***
'***OTHER***
Public Function ToString() As String
'on error resume next
Dim IndexFor As Long
'begin
For IndexFor = 1& To IndexNumberGlobal
ToString = ToString + CStr(IndexArrayGlobal(IndexFor)) + ","
Next IndexFor
If (Len(ToString)) Then ToString = VBA.Left$(ToString, Len(ToString) ‑ 1&) 'cut last comma
End Function
'***END OF OTHER***
[END OF FILE]